home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / stringsLists.tcl < prev    next >
Encoding:
Text File  |  1997-12-17  |  11.0 KB  |  412 lines  |  [TEXT/ALFA]
  1. #
  2. # strings.tcl (Mark Nagata and Tom Scavo and Vince Darley)
  3. #
  4.  
  5. namespace eval quote {}
  6. namespace eval text {}
  7. ## 
  8.  # -------------------------------------------------------------------------
  9.  # 
  10.  # "quote::" --
  11.  # 
  12.  # Manipulate string so search and insertion procedures work as expected.
  13.  # These files have been both renamed and rewritten from the former
  14.  # 'quoteExpr' procs.  They fix a number of bugs, and make their purpose
  15.  # clear.  There were numerous examples throughout Alpha's Tcl code which
  16.  # used the wrong quote function under the old scheme.
  17.  # 
  18.  # quote::Find
  19.  # 
  20.  #     use this for 'glob' type searches.
  21.  #     
  22.  # quote::Regfind
  23.  # 
  24.  #  use this for regexp searches
  25.  #  
  26.  # quote::Insert
  27.  # 
  28.  #  Quotes any block of text captured from a window so it can be used as a 
  29.  #  Tcl string. e.g. 'set a [quote::Insert [getSelect]] ; eval insertText $a'
  30.  #  will work correctly.  Can be used to generate procedures on the fly,
  31.  #  especially to add to your prefs.tcl:
  32.  #   set a [quote::Insert [getSelect]]
  33.  #   addUserLine "proc foo \{\} \{ return \"$a\" \}"
  34.  # 
  35.  # quote::Regsub
  36.  # 
  37.  #  use this for the replacement expression.  A common usage might look
  38.  #  like this:
  39.  #   
  40.  #   regsub -all [quote::Regfind $from] [read $cid] [quote::Regsub $to] out
  41.  # -------------------------------------------------------------------------
  42.  ##
  43. proc quote::Find  str {
  44.     regsub -all {[][\|*+()]} $str {\\&} str
  45.     return $str
  46. }
  47.  
  48. proc quote::Regfind str {
  49.     regsub -all {[][\$?^|*+()\.\{\}]} $str {\\&} str
  50.     return $str
  51. }
  52.  
  53. proc quote::Insert str {
  54.     regsub -all {[][\$"\{\}]} $str {\\&} str
  55.     regsub -all "\[\r\n\]" $str "\\r" str
  56.     regsub -all "\t" $str "\\t" str
  57.     return $str
  58. }
  59.  
  60. proc quote::Regsub str {
  61.     regsub -all {(\\|&)} $str {\\&} str
  62.     return $str
  63. }
  64.  
  65. ## 
  66.  # -------------------------------------------------------------------------
  67.  # 
  68.  # "quote::Prettify" --
  69.  # 
  70.  #  Since we're supposed to be a LaTeX editor, we handle symbols with
  71.  #  TeX in a bit differently
  72.  # -------------------------------------------------------------------------
  73.  ##
  74. proc quote::Prettify str {
  75.     set a [string toupper [string index $str 0]]
  76.     regsub -all {([^A-Z])([A-Z])} [string range $str 1 end] {\1 \2} b
  77.     regsub -all {((La|Bib|Oz) )?Te X} $a$b {\2TeX } a
  78.     regsub -all {::} $a {-} a
  79.     return $a
  80. }
  81. proc quote::Menuify str {
  82.     set a [string toupper [string index $str 0]]
  83.     regsub -all {([^A-Z])([A-Z])} [string range $str 1 end] {\1 \2} b
  84.     append a $b
  85. }
  86. ## 
  87.  # -------------------------------------------------------------------------
  88.  # 
  89.  # "quote::WhitespaceReg" --
  90.  # 
  91.  #  Quote a string so you can search for it ignoring all problems with
  92.  #  whitespace: all sequences of space/tab/cr are treated alike.
  93.  # -------------------------------------------------------------------------
  94.  ##
  95. proc quote::WhitespaceReg { str } { 
  96.     regsub -all "\[ \t\r\]+" $str {[ \t\r]+} str
  97.     return $str
  98. }
  99.  
  100. ## 
  101.  # -------------------------------------------------------------------------
  102.  # 
  103.  # "lremove" --
  104.  # 
  105.  #  removes items from a list
  106.  #  
  107.  #  options are '-all' to remove all, and -glob, -exact or -regexp
  108.  #  for search type.  '-exact' is the default. '--' terminates options.
  109.  #  
  110.  #  lremove ?-opts? l args
  111.  #  
  112.  #  Note: if you want to remove all items of list 'b' from list 'a',
  113.  #  the following is incorrect: lremove $a $b, you must use
  114.  #  'eval lremove [list $a] $b', so that b is expanded.
  115.  #  
  116.  #  There is now a new option -l which treats the extra args as lists,
  117.  #  so you can do lremove -l $a $b if you want.
  118.  # -------------------------------------------------------------------------
  119.  ##
  120. proc lremove {args} {
  121.     set opts(-all) 0
  122.     set type "-exact"
  123.     getOpts
  124.     set l [lindex $args 0]
  125.     if [info exists opts(-glob)] { set type "-glob" }
  126.     if [info exists opts(-regexp)] { set type "-regexp" }
  127.     if [info exists opts(-l)] { 
  128.         set args [join [lreplace $args 0 0] " "]
  129.     } else {
  130.         set args [lreplace $args 0 0]
  131.     }
  132.     foreach i $args {
  133.         if {[set ix [lsearch $type $l $i]] == -1} continue
  134.         set l [lreplace $l $ix $ix]
  135.         if {$opts(-all)} {
  136.             while {[set ix [lsearch $type $l $i]] != -1} {
  137.                 set l [lreplace $l $ix $ix]
  138.             }
  139.         }
  140.     }
  141.     return $l
  142. }
  143.  
  144. ## 
  145.  # -------------------------------------------------------------------------
  146.  # 
  147.  # "getOpts" --
  148.  # 
  149.  #  Rudimentary option passing.  Uses upvar to get to the 'args' list of
  150.  #  the calling procedure and scans that.  Option information is stored
  151.  #  in the 'opts' array of the calling procedure.
  152.  #  
  153.  #  Options are assumed to be flags, unless they occur in the optional
  154.  #  parameter list.  Then they are variables which take a value; the
  155.  #  next item in the args list.  If an item is a pair, then the first
  156.  #  is the var name and the second the number of arguments to give it.
  157.  # -------------------------------------------------------------------------
  158.  ##
  159. proc getOpts {{take_value ""} {set "set"}} {
  160.     upvar args a
  161.     upvar opts o
  162.     while {[string match \-* [set arg [lindex $a 0]]]} {
  163.         set a [lreplace $a 0 0]
  164.         if {$arg == "--"} {
  165.             return
  166.         } else {
  167.             if {[set idx [lsearch -regexp $take_value \
  168.               "^-?[string range $arg 1 end]( .*)?$"]] == -1} {
  169.                 set o($arg) 1
  170.             } else {
  171.                 if {[llength [set the_arg [lindex $take_value $idx]]] == 1} {
  172.                     $set o($arg) [lindex $a 0]
  173.                     set a [lreplace $a 0 0]
  174.                 } else {
  175.                     set numargs [expr [lindex $the_arg 1] -1]
  176.                     $set o($arg) [lrange $a 0 $numargs]
  177.                     set a [lreplace $a 0 $numargs]
  178.                 }
  179.             }
  180.         }
  181.     }
  182. }
  183.  
  184. ## 
  185.  # -------------------------------------------------------------------------
  186.  # 
  187.  # "ensureset" --
  188.  # 
  189.  #  Ensure the given variable is set, if it is unset, set it to the given
  190.  #  value.  This works with both variables and array elements, including
  191.  #  things which contain spaces etc.
  192.  # -------------------------------------------------------------------------
  193.  ##
  194. proc ensureset {v {val ""}} {
  195.     if [uplevel [list info exists $v]] { return [uplevel [list set $v]] }
  196.     return [uplevel [list set $v $val]]
  197. }
  198. ## 
  199.  # -------------------------------------------------------------------------
  200.  # 
  201.  # "lunion" --
  202.  # 
  203.  #  Basic use: make sure a given list variable contains each element 
  204.  #  of 'args'
  205.  #  
  206.  #  "llunion" --
  207.  #  
  208.  #  Advanced use: make sure a given list variable and index contains
  209.  #  an element whose i'th index matches the i'th index of one of 'args'.
  210.  #  In this case we call the proc with a list {var i} as first argument.
  211.  # -------------------------------------------------------------------------
  212.  ##
  213. proc lunion {var args} {
  214.     upvar $var a
  215.     if ![info exists a] {
  216.         set a $args
  217.         return
  218.     } else {
  219.         foreach item $args {
  220.             if {[lsearch $a $item] == -1} {
  221.                 lappend a $item
  222.             }
  223.         }
  224.     }
  225. }
  226.     
  227. proc llunion {var idx args} {
  228.     upvar $var a
  229.     if ![info exists a] {
  230.         set a $args
  231.         return
  232.     } else {
  233.         foreach item $args {
  234.             set add 1
  235.             foreach i $a {
  236.                 if {[lindex $i $idx] == [lindex $item $idx]} {
  237.                     set add 0
  238.                     break
  239.                 }
  240.             }
  241.             if {$add} {
  242.                 lappend a $item
  243.             }
  244.         }
  245.     }
  246. }
  247.  
  248. proc lunique {l} {
  249.     set lout ""
  250.     foreach f $l {
  251.         if {![info exists silly($f)]} {
  252.             set silly($f) 1
  253.             lappend lout $f
  254.         }
  255.     }
  256.     return $lout
  257. }
  258.             
  259. proc lreverse {l} {
  260.     if {[llength $l] > 1} {
  261.         set first [lindex $l 0]
  262.         set l [lreverse [lrange $l 1 end]]
  263.         lappend l $first
  264.     }
  265.     return $l
  266. }
  267.  
  268. proc lcontains {l e} {
  269.     upvar $l ll
  270.     if {[info exists ll] && [lsearch -exact $ll $e] != -1} {
  271.         return 1
  272.     } else {
  273.         return 0
  274.     }
  275. }
  276.  
  277. ## 
  278.  # -------------------------------------------------------------------------
  279.  # 
  280.  # "llindex" --
  281.  # 
  282.  #  Find the first index of a given list within another list.  
  283.  # -------------------------------------------------------------------------
  284.  ##
  285. proc llindex {l e args} {
  286.     upvar $l ll
  287.     if ![info exists ll] { return -1 }
  288.     if {$args == ""} {
  289.         return [lsearch -exact $ll $e]
  290.     } else {
  291.         set i 0
  292.         set len [llength $args]
  293.         while {$i < [llength $ll] - $len} {
  294.             if {[lindex $ll $i] == $e} {
  295.                 set range [lrange $ll [expr $i +1] [expr $i + $len]]
  296.                 for {set j 0} {$j < $len} {incr j} {
  297.                     if {[lindex $args $j] != [lindex $range $j]} {
  298.                         break
  299.                     }
  300.                 }
  301.                 if {$j == $len} { return $i}
  302.             }
  303.             incr i
  304.         }
  305.         return -1
  306.     }
  307. }
  308.  
  309. ########################################
  310. #                                       #
  311. #    A few random lisp'ish functions.   #
  312. #                                       #
  313. ########################################
  314.  
  315. proc car {l} {lindex $l 0}
  316. proc cadr {l} {lindex $l 1}
  317. proc caddr {l} {lindex $l 2}
  318. proc cadddr {l} {lindex $l 3}
  319. proc caddddr {l} {lindex $l 4}
  320. proc cdr {l} {lrange $l 1 end}
  321. proc cddr {l} {lrange $l 2 end}
  322. proc cons {e l} {concat [list $e] $l}
  323. proc mapcar args {return [eval map $args]}
  324.  
  325. proc map {func l} {
  326.     set out {}
  327.     foreach el $l {
  328.         lappend out [eval $func [list $el]]
  329.     }
  330.     return $out
  331. }
  332.  
  333. # Returns a modified text string if the string $text is non-null, 
  334. # and the null string otherwise.  The argument 'operation' is a 
  335. # string directing 'doSuffixText' to either "insert" or "remove" 
  336. # $suffixString to/from each line of $text.
  337. proc doSuffixText {operation suffixString text} {
  338.     if {$text == ""} {return ""}
  339.     set suff [quote::Find $suffixString]
  340.     if {$operation == "insert"} {
  341.         set str ${suffixString}\r
  342.         regsub -all \r $text $str text
  343.     } elseif {$operation == "remove"} {
  344.         set str ${suff}\r
  345.         regsub -all $str $text \r text
  346.     }
  347.     return $text
  348. }
  349.  
  350. # Returns a modified text string if the string $text is non-null, 
  351. # and the null string otherwise.  The argument 'operation' is a 
  352. # string directing 'doPrefixText' to either "insert" or "remove" 
  353. # $prefixString to/from each line of $text.  See latexEngine.tcl
  354. # for an example.
  355. proc doPrefixText {operation prefixString text} {
  356.     if {$text == ""} {return ""}
  357.     set pref [quote::Find $prefixString]
  358.     if {$operation == "insert"} {
  359.         set trailChar ""
  360.         set textLen [string length $text]
  361.         if {[string index $text [expr $textLen-1]] == "\r"} {
  362.             set text [string range $text 0 [expr $textLen-2]]
  363.             set trailChar "\r"
  364.         }
  365.         set str \r$prefixString
  366.         regsub -all \r $text $str text
  367.         return $prefixString$text$trailChar
  368.     } elseif {$operation == "remove"} {
  369.         regsub -all \r$pref $text \r text
  370.         regsub ^$pref $text "" text
  371.         return $text
  372.     }
  373. }
  374.  
  375. proc text::british {v} {
  376.     uplevel "regsub -all -nocase {(Colo)r} \[set $v\] {\\1ur} $v"
  377. }
  378.  
  379. rename getAscii {}
  380. proc getAscii {} {
  381.     set c [lookAt [getPos]]
  382.     scan $c %c decVal
  383.     set asOctal [format %o $decVal]
  384.     set asHex   [format %x $decVal]
  385.     alertnote "saw a \"$c\", $decVal -decimal,\
  386.       \\$asOctal -octal, x$asHex -hex"
  387. }
  388.  
  389. # nabbed from html mode
  390. set text::_Ascii "\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017"
  391. append text::_Ascii "\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
  392. append text::_Ascii " !\"#\$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  393. append text::_Ascii "\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177ÄÅÇÉÑÖÜáàâäãåçéèêë"
  394. append text::_Ascii "íìîïñóòôöõúùûü†°¢£§•¶ß®©™´¨≠ÆØ∞±≤≥¥µ∂∑∏π∫ªºΩæø¿¡¬√ƒ≈Δ«»… ÀÃÕŒœ–—"
  395. append text::_Ascii "“”‘’÷◊ÿŸ⁄€‹›fifl‡·‚„‰ÂÊÁËÈÍÎÏÌÓÔÒÚÛÙıˆ˜¯˘˙˚¸˝˛ˇ"
  396. proc text::Ascii {char {num 0}} {
  397.     if {$char == ""} {return 0}
  398.     global text::_Ascii
  399.     if {$num} {
  400.         if {$char > 256 || $char < 1} { beep ; message "text::Ascii called with bad argument" }
  401.         return [string index ${text::_Ascii} [expr $char - 1]]
  402.     } else {
  403.         return [expr 1 + [string first $char ${text::_Ascii}]]
  404.     }
  405. }
  406.  
  407. # Useful for -command flag of 'lsort'.
  408. proc sortByTail {one two} {
  409.     string compare [file tail $one] [file tail $two]
  410. }
  411.  
  412.